home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / libguile / record.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-08-02  |  13.1 KB  |  539 lines
  1. /*
  2.  * 
  3.  * This program is free software; you can redistribute it and/or modify
  4.  * it under the terms of the GNU General Public License as published by
  5.  * the Free Software Foundation; either version 2, or (at your option)
  6.  * any later version.
  7.  * 
  8.  * This program is distributed in the hope that it will be useful,
  9.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11.  * GNU General Public License for more details.
  12.  * 
  13.  * You should have received a copy of the GNU General Public License
  14.  * along with this software; see the file COPYING.  If not, write to
  15.  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16.  *
  17.  * As a special exception, the Free Software Foundation gives permission
  18.  * for additional uses of the text contained in its release of GUILE.
  19.  *
  20.  * The exception is that, if you link the GUILE library with other files
  21.  * to produce an executable, this does not by itself cause the
  22.  * resulting executable to be covered by the GNU General Public License.
  23.  * Your use of that executable is in no way restricted on account of
  24.  * linking the GUILE library code into it.
  25.  *
  26.  * This exception does not however invalidate any other reasons why
  27.  * the executable file might be covered by the GNU General Public License.
  28.  *
  29.  * This exception applies only to the code released by the
  30.  * Free Software Foundation under the name GUILE.  If you copy
  31.  * code from other Free Software Foundation releases into a copy of
  32.  * GUILE, as the General Public License permits, the exception does
  33.  * not apply to the code that you add in this way.  To avoid misleading
  34.  * anyone as to the status of such modified files, you must delete
  35.  * this exception notice from them.
  36.  *
  37.  * If you write modifications of your own for GUILE, it is your choice
  38.  * whether to permit this exception to apply to your modifications.
  39.  * If you do not wish that, delete this exception notice.  
  40.  */
  41.  
  42.  
  43. #include <stdio.h>
  44. #include "_scm.h"
  45.  
  46.  
  47.  
  48. typedef struct
  49. {
  50.   SCM rtd;
  51.   SCM name;
  52.   SCM fields;
  53.   SCM printer;
  54. } rtd_type;
  55.  
  56. typedef union
  57. {
  58.   struct
  59.     {
  60.       SCM proc;
  61.       SCM rtd;
  62.     } pred;
  63.   struct
  64.     {
  65.       SCM proc;
  66.       SCM rtd;
  67.       SCM index;
  68.     } acc;
  69.   struct
  70.     {
  71.       SCM proc;
  72.       SCM rtd;
  73.       SCM recsize;
  74.       SCM indices;
  75.     } constr;
  76. } rec_cclo;
  77.  
  78. long scm_tc16_record;
  79.  
  80. /* Record-type-descriptor for record-type-descriptors */
  81. static SCM the_rtd_rtd;
  82.  
  83. /* Record <= [rtd, ... elts ... ] */
  84. #define REC_RTD(x) (VELTS(x)[0])
  85. #define RECP(x) (scm_tc16_record==TYP16(x))
  86. #define RTDP(x) (RECP(x) && the_rtd_rtd==REC_RTD(x))
  87. #define RTD_NAME(x) (((rtd_type *)CDR(x))->name)
  88. #define RTD_FIELDS(x) (((rtd_type *)CDR(x))->fields)
  89. #define RTD_PRINTER(x) (((rtd_type *)CDR(x))->printer)
  90. #define RCLO_RTD(x) (((rec_cclo *)CDR(x))->pred.rtd)
  91.  
  92. #ifdef ARRAYS
  93. #define MAKE_REC_INDS(n) scm_make_uve((long)n, MAKINUM(1))
  94. #define REC_IND_REF(x, i) VELTS(x)[(i)]
  95. #define REC_IND_SET(x, i, val) VELTS(x)[(i)] = (val)
  96. #else
  97. #define MAKE_REC_INDS(n) scm_make_vector(MAKINUM(n), INUM0)
  98. #define REC_IND_REF(x, i) INUM(VELTS(x)[(i)])
  99. #define REC_IND_SET(x, i, val) VELTS(x)[(i)] = MAKINUM(val)
  100. #endif
  101.  
  102. static char s_record[] = "record";
  103.  
  104. PROC (s_record_p, "record?", 1, 0, 0, scm_record_p);
  105. #ifdef __STDC__
  106. SCM 
  107. scm_record_p (SCM obj)
  108. #else
  109. SCM 
  110. scm_record_p (obj)
  111.      SCM obj;
  112. #endif
  113. {
  114.   return (NIMP (obj) && RECP (obj) ? BOOL_T : BOOL_F);
  115. }
  116.  
  117.  
  118. PROC (s_record_predicate_procedure, " record-predicate-procedure", 2, 0, 0, scm_record_predicate_procedure);
  119. #ifdef __STDC__
  120. static SCM 
  121. scm_record_predicate_procedure (SCM cclo, SCM obj)
  122. #else
  123. static SCM 
  124. scm_record_predicate_procedure (cclo, obj)
  125.      SCM cclo;
  126.      SCM obj;
  127. #endif
  128. {
  129.   if (NIMP (obj) && RECP (obj) && (REC_RTD (obj) == RCLO_RTD (cclo)))
  130.     return BOOL_T;
  131.   return BOOL_F;
  132. }
  133.  
  134.  
  135. static SCM f_record_predicate_procedure;
  136.  
  137. PROC (s_record_predicate, "record-predicate", 1, 0, 0, scm_record_predicate);
  138. #ifdef __STDC__
  139. SCM 
  140. scm_record_predicate (SCM rtd)
  141. #else
  142. SCM 
  143. scm_record_predicate (rtd)
  144.      SCM rtd;
  145. #endif
  146. {
  147.   SCM cclo = scm_makcclo (f_record_predicate_procedure, 2L);
  148.   ASSERT (NIMP (rtd) && RTDP (rtd), rtd, ARG1, s_record_predicate);
  149.   RCLO_RTD (cclo) = rtd;
  150.   return cclo;
  151. }
  152.  
  153.  
  154. PROC (s_record_type_descriptor, "record-type-descriptor", 1, 0, 0, scm_record_type_descriptor);
  155. #ifdef __STDC__
  156. SCM 
  157. scm_record_type_descriptor (SCM rec)
  158. #else
  159. SCM 
  160. scm_record_type_descriptor (rec)
  161.      SCM rec;
  162. #endif
  163. {
  164.   if (IMP (rec) || !RECP (rec))
  165.     return BOOL_F;
  166.   return REC_RTD (rec);
  167. }
  168.  
  169. static SCM f_record_constructor_procedure;
  170.  
  171. PROC (s_record_constructor, "record-constructor", 1, 1, 0, scm_record_constructor);
  172. #ifdef __STDC__
  173. SCM 
  174. scm_record_constructor (SCM rtd, SCM flds)
  175. #else
  176. SCM 
  177. scm_record_constructor (rtd, flds)
  178.      SCM rtd;
  179.      SCM flds;
  180. #endif
  181. {
  182.   SCM flst, fld;
  183.   SCM cclo = scm_makcclo (f_record_constructor_procedure, (long) sizeof (rec_cclo) / sizeof (SCM));
  184.   rec_cclo *ptr = (rec_cclo *) CDR (cclo);
  185.   sizet i, j;
  186.   ASSERT (NIMP (rtd) && RTDP (rtd), rtd, ARG1, s_record_constructor);
  187.   ptr->constr.rtd = rtd;
  188.   i = scm_ilength (RTD_FIELDS (rtd));
  189.   ptr->constr.recsize = MAKINUM (i);
  190.   if (UNBNDP (flds))
  191.     {
  192.       ptr->constr.indices = MAKE_REC_INDS (i);
  193.       while (i--)
  194.     REC_IND_SET (ptr->constr.indices, i, i + 1);
  195.     }
  196.   else
  197.     {
  198.       ASSERT (NIMP (flds) && CONSP (flds), flds, ARG2, s_record_constructor);
  199.       ptr->constr.indices = MAKE_REC_INDS (scm_ilength (flds));
  200.       for (i = 0; NIMP (flds); i++, flds = CDR (flds))
  201.     {
  202.       fld = CAR (flds);
  203.       ASSERT (NIMP (fld) && SYMBOLP (fld), fld, ARG2, s_record_constructor);
  204.       flst = RTD_FIELDS (rtd);
  205.       for (j = 0;; j++, flst = CDR (flst))
  206.         {
  207.           if (fld == CAR (flst))
  208.         {
  209.           REC_IND_SET (ptr->constr.indices, i, j + 1);
  210.           break;
  211.         }
  212.           ASSERT (NNULLP (flst), fld, ARG2, s_record_constructor);
  213.         }
  214.     }
  215.     }
  216.   return cclo;
  217. }
  218.  
  219. PROC (s_record_constructor_procedure, " record-constructor-procedure", 0, 0, 1, scm_record_constructor_procedure);
  220. #ifdef __STDC__
  221. static SCM 
  222. scm_record_constructor_procedure (SCM args)
  223. #else
  224. static SCM 
  225. scm_record_constructor_procedure (args)
  226.      SCM args;
  227. #endif
  228. {
  229.   SCM cclo = CAR (args);
  230.   SCM rec, inds = (((rec_cclo *) CDR (cclo))->constr.indices);
  231.   sizet i = INUM (((rec_cclo *) CDR (cclo))->constr.recsize);
  232.   args = CDR (args);
  233.   NEWCELL (rec);
  234.   DEFER_INTS;
  235.   SETCHARS (rec, scm_must_malloc ((i + 1L) * sizeof (SCM), s_record));
  236.   SETNUMDIGS (rec, i + 1L, scm_tc16_record);
  237.   ALLOW_INTS;
  238.   while (i--)
  239.     VELTS (rec)[i + 1] = UNSPECIFIED;
  240.   REC_RTD (rec) = RCLO_RTD (cclo);
  241.   for (i = 0; i < LENGTH (inds); i++, args = CDR (args))
  242.     {
  243.       ASSERT (NNULLP (args), SCM_UNDEFINED, WNA, s_record_constructor_procedure);
  244.       VELTS (rec)[REC_IND_REF (inds, i)] = CAR (args);
  245.     }
  246.   ASSERT (NULLP (args), SCM_UNDEFINED, WNA, s_record_constructor_procedure);
  247.   return rec;
  248.  
  249. }
  250.  
  251.  
  252. /* Makes an accessor or modifier.
  253.    A cclo with 2 env elts -- rtd and field-number. */
  254. #ifdef __STDC__
  255. static SCM 
  256. makrecclo (SCM proc, SCM rtd, SCM field, char *what)
  257. #else
  258. static SCM 
  259. makrecclo (proc, rtd, field, what)
  260.      SCM proc;
  261.      SCM rtd;
  262.      SCM field;
  263.      char *what;
  264. #endif
  265. {
  266.   SCM flst;
  267.   SCM cclo = scm_makcclo (proc, 3L);
  268.   int i;
  269.   ASSERT (RTDP (rtd), rtd, ARG1, what);
  270.   ASSERT (NIMP (field) && SYMBOLP (field), field, ARG2, what);
  271.   RCLO_RTD (cclo) = rtd;
  272.   flst = RTD_FIELDS (rtd);
  273.   for (i = 1;; i++)
  274.     {
  275.       ASSERT (NNULLP (flst), field, ARG2, what);
  276.       if (CAR (flst) == field)
  277.     break;
  278.       flst = CDR (flst);
  279.     }
  280.   (((rec_cclo *) CDR (cclo))->acc.index) = MAKINUM (i);
  281.   return cclo;
  282. }
  283.  
  284.  
  285. PROC (s_rec_accessor1, " rec-accessor1", 2, 0, 0, scm_rec_accessor1);
  286. #ifdef __STDC__
  287. static SCM 
  288. scm_rec_accessor1 (SCM cclo, SCM rec)
  289. #else
  290. static SCM 
  291. scm_rec_accessor1 (cclo, rec)
  292.      SCM cclo;
  293.      SCM rec;
  294. #endif
  295. {
  296.   ASSERT (NIMP (rec) && RECP (rec), rec, ARG1, s_rec_accessor1);
  297.   ASSERT (RCLO_RTD (cclo) == REC_RTD (rec), rec, ARG1, s_rec_accessor1);
  298.   return VELTS (rec)[INUM (((rec_cclo *) CDR (cclo))->acc.index)];
  299. }
  300.  
  301.  
  302. PROC (s_rec_modifier1, " rec-modifier1", 3, 0, 0, scm_rec_modifier1);
  303. #ifdef __STDC__
  304. static SCM 
  305. scm_rec_modifier1 (SCM cclo, SCM rec, SCM val)
  306. #else
  307. static SCM 
  308. scm_rec_modifier1 (cclo, rec, val)
  309.      SCM cclo;
  310.      SCM rec;
  311.      SCM val;
  312. #endif
  313. {
  314.   ASSERT (NIMP (rec) && RECP (rec), rec, ARG1, s_rec_modifier1);
  315.   ASSERT (RCLO_RTD (cclo) == REC_RTD (rec), rec, ARG1, s_rec_modifier1);
  316.   VELTS (rec)[INUM (((rec_cclo *) CDR (cclo))->acc.index)] = val;
  317.   return UNSPECIFIED;
  318. }
  319.  
  320.  
  321. static SCM f_rec_accessor1;
  322.  
  323.  
  324. PROC (s_record_accessor, "record-accessor", 2, 0, 0, scm_record_accessor);
  325. #ifdef __STDC__
  326. SCM 
  327. scm_record_accessor (SCM rtd, SCM field)
  328. #else
  329. SCM 
  330. scm_record_accessor (rtd, field)
  331.      SCM rtd;
  332.      SCM field;
  333. #endif
  334. {
  335.   return makrecclo (f_rec_accessor1, rtd, field, s_record_accessor);
  336. }
  337.  
  338.  
  339. static SCM f_rec_modifier1;
  340.  
  341. PROC (s_record_modifier, "record-modifier", 2, 0, 0, scm_record_modifier);
  342. #ifdef __STDC__
  343. SCM 
  344. scm_record_modifier (SCM rtd, SCM field)
  345. #else
  346. SCM 
  347. scm_record_modifier (rtd, field)
  348.      SCM rtd;
  349.      SCM field;
  350. #endif
  351. {
  352.   return makrecclo (f_rec_modifier1, rtd, field, s_record_modifier);
  353. }
  354.  
  355.  
  356.  
  357. SCM *scm_loc_makrtd;
  358.  
  359. PROC (s_make_record_type, "make-record-type", 2, 0, 1, scm_make_record_type);
  360. #ifdef __STDC__
  361. SCM 
  362. scm_make_record_type (SCM name, SCM fields, SCM args)
  363. #else
  364. SCM 
  365. scm_make_record_type (name, fields, args)
  366.      SCM name;
  367.      SCM fields;
  368.      SCM args;
  369. #endif
  370. {
  371.   SCM n;
  372.   SCM printer;
  373.  
  374. #ifndef RECKLESS
  375.   ASSERT(SYMBOLP(name), name, ARG1, s_make_record_type);
  376.  
  377.   if (scm_ilength (fields) < 0)
  378.   errout:scm_wta (fields, (char *) ARG2, s_make_record_type);
  379.   for (n = fields; NIMP (n); n = CDR (n))
  380.     if (!SYMBOLP (CAR (n)))
  381.       goto errout;
  382.  
  383.   if (NIMP(args) && CONSP(args)) {
  384.     printer = CAR(args);
  385.     args = CDR(args);
  386.   } else
  387.     printer = BOOL_F;
  388.  
  389. #endif
  390.   return scm_apply(*scm_loc_makrtd,
  391.            name, scm_cons2 (fields, printer, listofnull));
  392. }
  393.  
  394.  
  395. #ifdef __STDC__
  396. static SCM 
  397. markrec (SCM ptr)
  398. #else
  399. static SCM 
  400. markrec (ptr)
  401.      SCM ptr;
  402. #endif
  403. {
  404.   sizet i;
  405.   if GC8MARKP
  406.     (ptr) return BOOL_F;
  407.   SETGC8MARK (ptr);
  408.   for (i = NUMDIGS (ptr); --i;)
  409.     if NIMP
  410.       (VELTS (ptr)[i]) scm_gc_mark (VELTS (ptr)[i]);
  411.   return REC_RTD (ptr);
  412. }
  413.  
  414.  
  415. #ifdef __STDC__
  416. static sizet 
  417. freerec (SCM ptr)
  418. #else
  419. static sizet 
  420. freerec (ptr)
  421.      SCM ptr;
  422. #endif
  423. {
  424.   scm_must_free (CHARS (ptr));
  425.   return sizeof (SCM) * NUMDIGS (ptr);
  426. }
  427.  
  428.  
  429. #ifdef __STDC__
  430. static int 
  431. recprin1 (SCM exp, SCM port, int writing)
  432. #else
  433. static int 
  434. recprin1 (exp, port, writing)
  435.      SCM exp;
  436.      SCM port;
  437.      int writing;
  438. #endif
  439. {
  440.   SCM rtd = REC_RTD(exp);
  441.   SCM name = RTD_NAME(rtd);
  442.   SCM pfunc = RTD_PRINTER(rtd);
  443.  
  444.   if (pfunc == BOOL_F) {
  445.     sizet i;
  446.     SCM names = RTD_FIELDS (rtd);
  447.  
  448.     scm_puts ("#s(", port);
  449.     scm_iprin1 (name, port, 0);
  450.  
  451.     for (i = 1; i < NUMDIGS (exp); i++)
  452.       {
  453.     scm_putc (' ', port);
  454.     scm_iprin1 (CAR (names), port, 0);
  455.     names = CDR (names);
  456.     scm_putc (' ', port);
  457.     scm_iprin1 (VELTS (exp)[i], port, writing);
  458.       }
  459.     scm_putc (')', port);
  460.   } else if (scm_procedurep(pfunc) != BOOL_F)
  461.     scm_apply(pfunc,
  462.           exp, scm_cons2(port, writing ? BOOL_T : BOOL_F, listofnull));
  463.   else {
  464.     scm_puts("#<", port);
  465.     scm_iprin1(name, port, 0);
  466.     scm_putc(' ', port);
  467.     scm_intprint(exp, 16, port);
  468.     scm_putc('>', port);
  469.   }
  470.  
  471.   return 1;
  472. }
  473.  
  474.  
  475. #ifdef __STDC__
  476. static SCM 
  477. scm_recequal (SCM rec0, SCM rec1)
  478. #else
  479. static SCM 
  480. scm_recequal (rec0, rec1)
  481.      SCM rec0;
  482.      SCM rec1;
  483. #endif
  484. {
  485.   sizet i = NUMDIGS (rec0);
  486.   if (i != NUMDIGS (rec1))
  487.     return BOOL_F;
  488.   if (REC_RTD (rec0) != REC_RTD (rec1))
  489.     return BOOL_F;
  490.   while (--i)
  491.     if (FALSEP (scm_equal (VELTS (rec0)[i], VELTS (rec1)[i])))
  492.     return BOOL_F;
  493.   return BOOL_T;
  494. }
  495.  
  496. static scm_smobfuns recsmob = {markrec, freerec, recprin1, scm_recequal};
  497.  
  498. static char s_name[] = "name";
  499. static char s_fields[] = "fields";
  500. static char s_printer[] = "printer";
  501.  
  502. #ifdef __STDC__
  503. void 
  504. scm_init_record (void)
  505. #else
  506. void 
  507. scm_init_record ()
  508. #endif
  509. {
  510.   SCM i_name = CAR (scm_intern (s_name, (sizeof s_name) - 1));
  511.   SCM i_fields = CAR (scm_intern (s_fields, (sizeof s_fields) - 1));
  512.   SCM i_printer = CAR (scm_intern (s_printer, (sizeof s_printer) - 1));
  513.   scm_tc16_record = scm_newsmob (&recsmob);
  514.  
  515.   NEWCELL (the_rtd_rtd);
  516.   SETCHARS (the_rtd_rtd, scm_must_malloc ((long) sizeof (rtd_type), s_record));
  517.   SETNUMDIGS (the_rtd_rtd, (long) sizeof (rtd_type) / sizeof (SCM), scm_tc16_record);
  518.  
  519.   REC_RTD (the_rtd_rtd) = the_rtd_rtd;
  520.   RTD_NAME (the_rtd_rtd) = scm_makfromstr (s_record, (sizeof s_record) - 1, 0);
  521.   RTD_FIELDS (the_rtd_rtd) = scm_cons(i_name, scm_cons2(i_fields, i_printer, EOL));
  522.   RTD_PRINTER (the_rtd_rtd) = BOOL_F;
  523.  
  524.   scm_sysintern ("record:rtd", the_rtd_rtd);
  525.  
  526. #include "record.x"
  527.  
  528.   f_record_predicate_procedure = CDR (scm_intern0 (s_record_predicate_procedure));
  529.   f_record_constructor_procedure = CDR (scm_intern0 (s_record_constructor_procedure));
  530.   f_rec_accessor1 = CDR (scm_intern0 (s_rec_accessor1));
  531.   f_rec_modifier1 = CDR (scm_intern0 (s_rec_modifier1));
  532.   scm_sysintern ("record-type-descriptor?", scm_record_predicate (the_rtd_rtd));
  533.   scm_sysintern ("record-type-name", scm_record_accessor (the_rtd_rtd, i_name));
  534.   scm_sysintern ("record-type-field-names", scm_record_accessor (the_rtd_rtd, i_fields));
  535.   scm_loc_makrtd = &CDR (scm_sysintern ("RTD:make", scm_record_constructor (the_rtd_rtd, SCM_UNDEFINED)));
  536.   scm_add_feature (s_record);
  537. }
  538.  
  539.